home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1994 November: Tool Chest / Dev.CD Nov 94.toast / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / interfaces / PInterface Translator / translate.lisp < prev   
Encoding:
Text File  |  1993-09-16  |  6.1 KB  |  138 lines  |  [TEXT/CCL2]
  1. (in-package :ccl)
  2.  
  3. ; 12/19/91 bill (def-logical-directory ...) -> (setf (logical-pathname-translations ...))
  4. ; ------------- 2.0b4
  5. ; 4/8/91  joe patch-interfaces is a lot faster now, but still sort of broken
  6. ;         one should still patch & check by hand!
  7. ;
  8.  
  9. (defpackage :translate (:use :common-lisp))
  10. (defpackage :translate* (:use))
  11. (setf (logical-pathname-translations "translate")
  12.       `(("translate:**;*.*"
  13.         ,(concatenate 'string
  14.                      (mac-directory-namestring *loading-file-source-file*)
  15.                      "**:*.*"))))
  16. (let ((path (pathname "translate:")))
  17.   (unless (member path *module-search-path* :test 'equal)
  18.     (push path *module-search-path*)))
  19. (require 'new-traps)
  20. (require '411-reader)
  21. (require 'pasc-reader)
  22. (require '411-traps)
  23.  
  24. ; translate a whole directory:
  25. ;
  26. (defun translate-all-pasc (&optional (flush t) (verbose t))
  27.   (when flush
  28.     (translate::flush-pasc-types))
  29.   (with-open-file (warnings "translate:warnings.text"
  30.                             :direction :output :if-exists :supersede)
  31.     (let ((*standard-output* (if verbose 
  32.                                *standard-output*
  33.                                warnings)))
  34.       (dolist (ifile (directory "translate:pinterfaces;*.p"))
  35.         (unless (member (pathname-name ifile) translate::*translated-files* 
  36.                         :test #'string-equal)
  37.           (translate::translate-pasc-file :input-path ifile
  38.                                           :output-path (merge-pathnames 
  39.                                                         "ccl:interfaces;.lisp" ifile)))))))
  40.  
  41. (defun translate-pasc-files (files &optional (ignore-includes t))
  42.   (let ((pasc-path "translate:pinterfaces;.p")
  43.         (lisp-path "ccl:interfaces;.lisp"))
  44.     (dolist (f files)
  45.       (translate::translate-pasc-file
  46.        :input-path (merge-pathnames pasc-path f)
  47.        :output-path (merge-pathnames lisp-path f)
  48.        :dont-translate-includes ignore-includes))))
  49.  
  50. ; This isn't quite right yet!
  51. (defun patch-interfaces (&key (animate t) (auto-save nil) (auto-close nil))
  52.   (dolist (patch-path (directory "translate:patches;*.patch"))
  53.     (patch-interface patch-path animate auto-save auto-close)))
  54.  
  55. (defun patch-interface (patch-path animate auto-save auto-close)
  56.   (let* ((interface-path (merge-pathnames "ccl:interfaces;.lisp" (pathname-name patch-path)))
  57.          (fred-window (fred interface-path))
  58.          (fred-buffer (fred-buffer fred-window))
  59.          (*package* *traps-package*))
  60.     (with-open-file (patch-stream patch-path)
  61.       (loop
  62.         (let* ((patch (read patch-stream nil nil))
  63.                (item-name (cadr patch))
  64.                (item-name-string nil)
  65.                (position 0))
  66.           (when (null patch) (return))
  67.           
  68.           (when (consp item-name)
  69.             (setq item-name (car item-name)))
  70.           (setq item-name-string (string item-name))
  71.           (unless
  72.             (loop
  73.               (setq position
  74.                     (buffer-forward-search fred-buffer item-name-string position))
  75.               (unless position
  76.                 (return nil))
  77.               (when (eq (buffer-read fred-buffer
  78.                                      (buffer-bwd-sexp fred-buffer position))
  79.                         item-name)
  80.                 (when animate
  81.                   (window-show-cursor fred-window position t))
  82.                 (let* ((start (ed-top-level-sexp-start-pos fred-buffer position)))
  83.                   (multiple-value-bind (form end)
  84.                                        (buffer-read fred-buffer start)
  85.                     (when animate
  86.                       (set-selection-range fred-window end start)
  87.                       (fred-update fred-window))
  88.                     (when (and (eq item-name (cadr form))
  89.                                (compatible (car form) (car patch)))
  90.                       (buffer-delete fred-buffer start end)
  91.                       (let ((comment-start (buffer-line-start fred-buffer
  92.                                                               start -1))
  93.                             (comment-end (buffer-line-start fred-buffer
  94.                                                             start 1)))
  95.                         (when (and (eq (buffer-char fred-buffer comment-start) #\#)
  96.                                    (eq (buffer-char fred-buffer (1+ comment-start)) #\|)
  97.                                    (eq (buffer-char fred-buffer comment-end) #\|)
  98.                                    (eq (buffer-char fred-buffer (1+ comment-end)) #\#))
  99.                           (buffer-delete fred-buffer comment-start
  100.                                          (+ comment-end 2))
  101.                           (setq start comment-start)))
  102.                       (buffer-insert fred-buffer (let ((*print-pretty* t))
  103.                                                    (prin1-to-string patch))
  104.                                      start)
  105.                       (return t))
  106.                     (incf position)))))
  107.             (when animate
  108.               (window-show-cursor fred-window (buffer-size fred-buffer) t))
  109.             (buffer-insert fred-buffer (let ((*print-pretty* t))
  110.                                          (prin1-to-string patch))
  111.                            (buffer-size fred-buffer))
  112.             (buffer-insert fred-buffer #\newline (buffer-size fred-buffer))
  113.             (when animate
  114.               (window-show-cursor fred-window (buffer-size fred-buffer) t))))
  115.         (when animate
  116.           (fred-update fred-window))))
  117.     (when auto-save (window-save fred-window))
  118.     (when auto-close (window-close fred-window))
  119.     ))
  120.  
  121. (defun compatible (defx defy)
  122.   (or (equal defx defy)
  123.       (and (equal defx 'traps::def-mactype)
  124.            (equal defy 'traps::defrecord))
  125.       (and (equal defy 'traps::def-mactype)
  126.            (equal defx 'traps::defrecord))))
  127.  
  128. (defun do-translation-run ()
  129.   (error "This doesn't really work!")
  130.   (translate-all-pasc)
  131.   (patch-interfaces)
  132.   (copy-file "translate:replacements;types.lisp" "ccl:interfaces;types.lisp"
  133.              :if-exists :supersede)
  134.   (copy-file "translate:replacements;sane.lisp" "ccl:interfaces;sane.lisp"
  135.              :if-exists :supersede)
  136.   (delete-file "ccl:interfaces;traps.lisp")
  137.   (reindex-interfaces))
  138.